
package Sgdb::DataBreakpoints ;

use Sgdb::Utils qw (:DEFAULT
                    ) ;



# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

# TODO? recovery mechanism?

init() ;

sub init {

    1 ;
}

sub ex_breakpoints_list {

    my $file = shift || '.' ;

    if ( $file =~ s/\*?0x//  ) {

        my $bp_cashed  = gdb_exec_quiet( 'info breakpoints' ) || '';

        return grep /^\d+\s+.*[yn]\s+0x0*$file/, split /\n/, $bp_cashed ;
    }
    else {

        $file =~ s/\.\.\/// ;
        my $bp_cashed  = gdb_exec_quiet( 'info breakpoints' ) || '' ;

        return grep /^\d+\s+.*[yn]\s+0x[a-f\d]+.*[ \/]\Q$file\E/, split /\n/, $bp_cashed ;
    }
# returns strings like
# 1   breakpoint     keep y   0x00526980 in lock_qr at ../lru.c:695
}


sub new {

    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $text = ( pref ('tracepoints-win-show-scrollbars') ?
                 $topf -> Scrolled ( 'ROText', pref 'tracepoints-win-text' ) :
                 $topf ->             ROText ( pref 'tracepoints-win-text' ) ) ;

    pref_tags $text, 'tracepoints-win', qw/header trace actions invalid-msg/ ;

    $text -> menu() -> configure ( -postcommand => [\&popup_tracpoints_menu, $text] ) ;

    $text -> tagRaise('sel') ;

    hook_add ('refresh-breakpoints' => [\&refresh_breakpoints, $text] ,
              'new-symbol-file'     => [\&new_symbol_file,     $text] ,
              'invalid-symbol-file' => [\&invalid_symbol_file, $text] ,
              );

    pref_reconfigure  'tracepoints-win-text' => $text  ;

    # return:
    # 1. unpacked text object
    # 2. update command
    ( $text,
      sub { refresh_breakpoints( $text, @_ ) }
    ) ;
}

sub popup_tracpoints_menu {

    my $t = shift ;

    my $m = $t -> menu () ;
    $m -> delete ( 0 => 'end' ) ;

    my $sm ;
    my @pref_menu_pop = pref 'pop-menu' ;

    my $current  = $t -> index   ( 'current' ) ;

    my ( $num, $enable, $addr, $file, $line ) ;

    while ( ! $num ) {

        my $trace = $t -> get ( "$current linestart" => "$current lineend" ) ;

#   Num Type           Disp Enb Address    What
#   1   breakpoint     keep y   0x004940d0 in lock_lru at ../lru.c:564
#   2   breakpoint     keep y   0x004b87a0 in handle_request at ../adbg_stub.c:1735

        if    ( $trace =~
                /^(\d+)\s+ breakpoint\s+ \w+ \s+
                ([yn]) \s+ (0x[\da-f]+) \s+ .* at \s+ (\S+):(\d+)/x ) {

            ($num, $enable, $addr, $file, $line) = ($1, $2, $3, $4, $5) ;
        }
        elsif ( $trace =~
                /^(\d+)\s+ breakpoint\s+ \w+ \s+
                ([yn]) \s+ (0x[\da-f]+) /x ) {

            ($num, $enable, $addr ) = ($1, $2, $3) ;
        }
        elsif ( $t -> compare ( $current, '<', "2.0" ) ) {

            return ;
        }
        else {

            $current = $t -> index ( "$current -1 line" ) ;
        }
    }

    my $anti_enable = ($enable eq 'y') ? 'disable' : 'enable ' ;

    my $selexists = $t -> tagRanges( 'sel' ) ;


    foreach my $menu ( ['command',
                        -label => "info line *$addr",
                        -command => [\&gdb_exec_lock, "info line *$addr" ]
                        ],
                       ['separator'
                        ],
                       ['command',
                        -label   => "delete $num",
                        -command => [\&gdb_exec_lock, "delete $num"]
                        ],
                       ['command',
                        -label   => "delete all",
                        -command => [\&gdb_exec_lock, "delete "]
                        ],
                       ['command',
                        -label   => 'delete selection',
                        -state   => $selexists ? 'normal' : 'disabled' ,
                        -command => [\&action_selection, $t, 'delete' ],
                        ],
                       ['separator'
                        ],
                       ['command',
                        -label   => "$anti_enable $num",
                        -command => [\&gdb_exec_lock, "$anti_enable $num"]
                        ],
                       ['command',
                        -label   => 'disable selection',
                        -state   => $selexists ? 'normal' : 'disabled' ,
                        -command => [\&action_selection, $t, 'disable' ],
                        ],
                       ['command',
                        -label   => 'enable  selection',
                        -state   => $selexists ? 'normal' : 'disabled' ,
                        -command => [\&action_selection, $t, 'enable' ]
                        ],
                       [ 'separator'
                         ],
                       ['command',
                        -label => 'Close',
                        -command => [\&hook_run, 'close-current-data-pane' ]
                        ],
                       ) { $m -> add ( @$menu ) }
}

sub action_selection {

    my ($t, $cmd ) = @_ ;

    my ($first, $last ) = $t -> tagRanges ( 'sel' ) ;

    for ( my $cur = $t -> index ( "$first linestart" )  ;
          $t -> compare ( $cur, '<', $last )            ;
          $cur = $t -> index ( "$cur +1 line" )         ) {

        $t -> get ( "$cur linestart", "$cur lineend" ) =~
            /^(\d+)\s+breakpoint\s+\w+\s+[yn]/
                or next ;

        my $num = $1 ;

        gdb_exec_quiet "$cmd $num" ;
    }

    hook_run 'refresh-breakpoints' ;
}

sub refresh_breakpoints {

    my $t = shift ;
    return telme 'no text' unless istkwidget $t ;

    my $tp = gdb_exec_quiet ( 'info breakpoints' ) or return ;

    my @tp ;

    foreach my $line ( split /^/, $tp ) {


        push
            @tp,
            $line,
            ( ( $line =~ /^Num/ ) ? 'header'  :
              ( $line =~ /^\d/  ) ? 'trace'   :
                                    'actions'
              );
    }

    $t -> delete    ( '1.0'  => 'end'      ) ;
    $t -> insert    ( 'end'  => @tp        ) ;
}

sub new_symbol_file {

    my $t = shift ;

    return telme 'no text' unless istkwidget $t ;

    $t -> delete ('1.0' => '1.0 lineend' ) ;
    $t -> insert    ( '1.0',
                      "Beware: Those Breakpoints are Probably Invalid" => 'invalid-msg'
                      ) ;
    $t -> see ( '1.0' ) ;
}

sub invalid_symbol_file {

    my $t = shift ;
    return telme 'no text' unless istkwidget $t ;

    $t -> delete ('1.0' => '1.0 lineend' ) ;
    $t -> insert    ( '1.0',
                      "Beware: Those Breakpoints are Probably Invalid" => 'invalid-msg'
                      ) ;
    $t -> see ( '1.0' ) ;
}

